home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacQForth 1.0 / source / QForth.plain < prev    next >
Encoding:
Text File  |  1995-03-28  |  47.0 KB  |  1,199 lines  |  [TEXT/ALFA]
  1. \ QForth plain, 8-bit 65C02 simulator to run QForth 1.1, 03-03-95
  2. \
  3. \ last modification, 03-03-95
  4. \
  5. \
  6. \ This should run under almost any 32-bit Forth system.  To run on a 
  7. \ 16-bit system change the 4 * in places indicated to a 2 *
  8. \
  9. \ To be fully functional, you need to write the code for all lines marked
  10. \ with a **** .  This is mainly graphics and disk access.
  11. \
  12. \
  13. \ Copyright (c) 1995, Ronald T. Kneusel, all rights reserved.
  14. \
  15. \
  16. \ Permission given to modify this code provided that credit is given
  17. \ where credit is due.
  18. \
  19. \
  20. \ Internet: kneusel@msupa.pa.msu.edu
  21. \           kneusel@studsys.mscs.mu.edu
  22. \           rtk@herman.gem.valpo.edu
  23. \
  24. \ Mail:     8725 West Burdick Ave.
  25. \           Milwaukee, WI 53227
  26. \           USA
  27. \           (414) 545-7557
  28. \
  29. \ Note:  This code is falling out of step with MacQForth.  Look at both
  30. \        files for a complete implementation.
  31. \
  32. \ ===========================================================================
  33.  
  34.  
  35. \ Section: Memory Access and Frequently used Words
  36.  
  37. hex \ switch to hexadecimal
  38.  
  39. \ Define memory, 64K = 65536 bytes
  40.  
  41. variable $0000 10000 allot  \ $0000 is base of memory, allot 64K
  42.  
  43. \ Memory access words, $@ and $!
  44.  
  45. : $@ ( address -- value )  $0000 + c@ ;  
  46.      
  47. : $! ( value address -- )  $0000 + c! ;
  48.  
  49. \ Define accumulator, X & Y registers, stack pointer, and program counter
  50.  
  51. variable A    variable X    variable Y
  52. variable S    variable PC   variable oldA  \ for overflow detection
  53.  
  54. ( Helpful words to know )  \ make all of these inline in final version
  55.  
  56. : fetch ( --  ) \ get & increment PC
  57.      PC @ dup $@ swap 1+ PC !  ;
  58. : >addr ( lo hi -- addr )  100 * +  ; \ make an address
  59. : a>v ( -- n )  fetch fetch >addr $@  ; ( get value at abs. addr )
  60. : addr> ( -- a )   fetch fetch >addr  ; ( leave address on stack )
  61. : z>v ( -- n )  fetch $@  ; ( get value at zero addr )
  62. : zaddr> ( -- a )  fetch  ; ( leave zero page address on stack )
  63. : push  ( n -- )  ( push stack to system stack )
  64.     S @ 1- dup 100 < if drop 1ff then dup S ! $!  ;
  65. : pull  ( -- n )  ( pull from system stack )
  66.     S @ dup $@ swap 1+ dup 1ff > if drop 1ff then S !  ;
  67. : pushPC ( -- )  ( push PC on system stack ) \ assumes a 32-bit forth
  68.     PC @ 1- PC ! PC 2+ c@ push PC 3 + c@ push  ; 
  69.     
  70. \ address mode access words
  71.  
  72. variable addr  \ holds memory address most recently accessed
  73.  
  74. : imm.  fetch  ;
  75. : zpg.  fetch dup addr ! $@  ;
  76. : zpx.  fetch X @ + dup addr ! $@  ;
  77. : zpi.  fetch dup 1+ $@ swap $@ swap 100 * + dup addr ! $@  ;
  78. : abs.  fetch fetch 100 * + dup addr ! $@  ;
  79. : abx.  fetch fetch 100 * + X @ + dup addr ! $@  ;
  80. : aby.  fetch fetch 100 * + Y @ + dup addr ! $@  ;
  81. : inx.  fetch X @ + dup 1+ $@ swap $@ swap 100 * + dup addr ! $@  ;
  82. : iny.  fetch dup 1+ $@ swap $@ swap 100 * + Y @ + dup addr ! $@  ;
  83.  
  84. \ Processor status flags are boolean variables
  85.  
  86. variable #N   \ negative
  87. variable #Z   \ zero
  88. variable #C   \ carry
  89. variable #I   \ interrupt
  90. variable #D   \ decimal mode
  91. variable #V   \ overflow
  92.  
  93. \ **** Update processor status ****
  94.  
  95. : set  -1 swap !  ;
  96. : unset  0 swap !  ;
  97. : @v  @ if 1 else 0 then ;  \ for use in ADC, SBC and PHP
  98. : v!  swap 0= if 0 else -1 then swap ! ;  \ for use in ROR and LSR
  99.  
  100. \ Relative branch instructions
  101.  
  102. : branch0  ( n -- )  \ unset PC to forward or backward branch
  103.    dup 80 < if
  104.      PC @ + PC ! \ forward branch
  105.    else
  106.      100 swap - PC @ swap - PC ! \ backward branch
  107.    then 
  108. ;
  109.  
  110. \ Section: 65C02 Instructions
  111.  
  112. \ ADC - Add to Accumulator with Carry
  113.   
  114.   \ set processor status flags
  115.   : psADC ( v -- ) 
  116.       >r r@ FF > if r@ 100 - A ! #C set else #C unset then  \ carry
  117.       r@ 0= if #Z set else #Z unset then    \ zero
  118.       r@ 7F > if #N set else #N unset then \ negative
  119.       r> 80 and oldA @ 80 and <> if #V set else #V unset then \ overflow
  120.   ; 
  121.   
  122.   : doADC  
  123.       A @ dup oldA ! + #C @v + dup A ! psADC 
  124.   ;   
  125.   
  126.   \ code
  127.   : $69 imm. doADC ; \ immediate
  128.   : $65 zpg. doADC ; \ zero page
  129.   : $75 zpx. doADC ; \ zero page,X
  130.   : $72 zpi. doADC ; \ zero page indirect
  131.   : $6D abs. doADC ; \ absolute
  132.   : $7D abx. doADC ; \ absolute,X  
  133.   : $79 aby. doADC ; \ absolute,Y
  134.   : $61 inx. doADC ; \ indirect,X
  135.   : $71 iny. doADC ; \ indirect,Y
  136.  
  137. \ AND - and Memory with Accumulator
  138.  
  139.   : psAND 
  140.      dup 0= if #Z set else #Z unset then \ zero
  141.      7F > if #N set else #N unset then  ; \ negative
  142.   
  143.   : doAND   A @ and dup A ! psAND  ;
  144.   
  145.   : $29 imm. doAND ; \ immediate
  146.   : $25 zpg. doAND ; \ zero page
  147.   : $32 zpi. doAND ; \ zero page indirect
  148.   : $35 zpx. doAND ; \ zero page,X
  149.   : $2D abs. doAND ; \ absolute
  150.   : $3D abx. doAND ; \ absolute,X
  151.   : $39 aby. doAND ; \ absolute,Y
  152.   : $21 inx. doAND ; \ indirect,X
  153.   : $31 iny. doAND ; \ indirect,Y
  154.  
  155.  
  156. \ ASL - Accumulator Shift Left
  157.  
  158.   : psASL dup FF > if 100 - #C set else #C unset then
  159.       dup 0= if #Z set else #Z unset then
  160.       dup 7F > if #N set else #N unset then
  161.   ;
  162.   
  163.   : $0A A @  2 * psASL A !  ;      \ accumulator
  164.   : $06 zpg. 2 * psASL addr @ $! ; \ zero page
  165.   : $16 zpx. 2 * psASL addr @ $! ; \ zero page,X
  166.   : $0E abs. 2 * psASL addr @ $! ; \ absolute
  167.   : $1E abx. 2 * psASL addr @ $! ; \ absolute,X
  168.  
  169.   
  170. \ BCC - Branch on Carry Clear
  171.  
  172.   : $90 imm. #C @ if drop else branch0 then ;
  173.  
  174. \ BCS - Branch on Carry Set
  175.  
  176.   : $B0 imm. #C @ if branch0 else drop then ;
  177.   
  178. \ BEQ - Branch on result Equal to Zero
  179.  
  180.   : $F0 imm. #Z @ if branch0 else drop then ;
  181.   
  182. \ BIT - Test Bits in Memory with Accumulator
  183.  
  184.   : doBIT ( n -- ) \ perform a BIT operation
  185.      dup dup
  186.      80 and 0= if #N unset else #N set then
  187.      40 and 0= if #V unset else #N set then
  188.      A @ and 0= if #Z set else #Z unset then ;
  189.  
  190.   : $89 imm. A @ and 0= if #Z set else #Z unset then ;
  191.   : $24 zpg. doBIT ;
  192.   : $34 zpx. doBIT ;
  193.   : $2C abs. doBIT ;
  194.   : $3C abx. doBIT ;
  195.  
  196. \ BMI - Branch on result minus
  197.  
  198.   : $30 imm. #N @ if branch0 else drop then ;
  199.   
  200. \ BNE - Branch on result not equal to zero
  201.  
  202.   : $D0 imm. #Z @ if drop else branch0 then ;
  203.  
  204. \ BPL - Branch on result plus
  205.  
  206.   : $10 imm. #N @ if drop else branch0 then ;
  207.  
  208. \ BRA - Branch relative always
  209.  
  210.   : $80 imm. branch0 ;
  211.   
  212. \ BRK - Break - enters the program whose address is $FFFE lo $FFFF hi
  213.  
  214.   : $00 FFFE $@ FFFF $@ 100 * + PC ! ;
  215.   
  216. \ BVC - Branch on overflow clear
  217.  
  218.   : $50 imm. #V @ if drop else branch0 then ;
  219.   
  220. \ BVS - Branch on overflow set
  221.  
  222.   : $70 imm. #V @ if branch0 else drop then ;
  223.   
  224. \ CLC - Clear Carry Flag
  225.  
  226.   : $18 #C unset ;
  227.   
  228. \ CLD - Clear Decimal Flag
  229.  
  230.   : $D8 #D unset ;
  231.   
  232. \ CLI - Clear Interrupt Disable
  233.  
  234.   : $58 #I unset ;
  235.   
  236. \ CLV - Clear overflow flag
  237.  
  238.   : $B8 #V unset ;
  239.   
  240. \ CMP - Compare Memory and Accumulator
  241.  
  242.   : doCMP 
  243.      dup A @ swap < if #N set #Z unset #C unset drop else
  244.      dup A @ = if #Z set #C set #N unset drop else
  245.          A @ swap > if #C set #Z unset #N unset then 
  246.      then then ;
  247.   
  248.   : $C9 imm. doCMP ;
  249.   : $C5 zpg. doCMP ;
  250.   : $D5 zpx. doCMP ;
  251.   : $D2 zpi. doCMP ;
  252.   : $CD abs. doCMP ;
  253.   : $DD abx. doCMP ;
  254.   : $D9 aby. doCMP ;
  255.   : $C1 inx. doCMP ;
  256.   : $D1 iny. doCMP ;
  257.  
  258. \ CPX - Compare Memory and X
  259.  
  260.   : doCPX 
  261.      dup X @ swap < if #N set #Z unset #C unset drop else
  262.      dup X @ = if #Z set #C set #N unset drop else
  263.          X @ swap > if #C set #Z unset #N unset then 
  264.      then then ;
  265.   
  266.   : $E0 imm. doCPX ;
  267.   : $E4 zpg. doCPX ;
  268.   : $EC abs. doCPX ;
  269.  
  270. \ CPY - Compare Memory and Y
  271.  
  272.   : doCPY 
  273.      dup Y @ swap < if #N set #Z unset #C unset drop else
  274.      dup Y @ = if #Z set #C set #N unset drop else
  275.          Y @ swap > if #C set #Z unset #N unset then 
  276.      then then ;
  277.   
  278.   : $C0 imm. doCPY ;
  279.   : $C4 zpg. doCPY ;
  280.   : $CC abs. doCPY ;
  281.  
  282. \ DEA - Decrement Accumulator
  283.  
  284.   : $3A A @ 1-
  285.    dup -1 = if drop FF A ! FF then
  286.    dup 0= if #Z set else #Z unset then
  287.    dup 7F > if #N set else #N unset then
  288.    A ! ;    
  289.  
  290. \ DEC - Decrement Memory by One
  291.  
  292.   : doDEC 1-
  293.      dup -1 = if drop FF then
  294.      dup 0= if #Z set else #Z unset then
  295.      dup 7F > if #N set else #N unset then
  296.      addr @ $! ;
  297.  
  298.   : $C6 zpg. doDEC ;
  299.   : $D6 zpx. doDEC ;
  300.   : $CE abs. doDEC ;
  301.   : $DE abx. doDEC ;
  302.  
  303. \ DEX - Decrement X by one
  304.  
  305.   : $CA X @ 1-
  306.      dup -1 = if drop FF X ! FF then
  307.      dup 0= if #Z set else #Z unset then
  308.      dup 7F > if #N set else #N unset then
  309.      X ! ;    
  310.  
  311. \ DEY - Decrement Y by one
  312.  
  313.   : $88 Y @ 1-
  314.      dup -1 = if drop FF Y ! FF then
  315.      dup 0= if #Z set else #Z unset then
  316.      dup 7F > if #N set else #N unset then
  317.      Y ! ;    
  318.  
  319. \ EOR - Exclusive OR Memory and Accumulator
  320.  
  321.   : psEOR 
  322.      dup 0= if #Z set else #Z unset then \ zero
  323.      7F > if #N set else #N unset then  ; \ negative
  324.   
  325.   : doEOR   A @ xor dup A ! psEOR  ;
  326.   
  327.   : $49 imm. doEOR ; \ immediate
  328.   : $45 zpg. doEOR ; \ zero page
  329.   : $52 zpi. doEOR ; \ zero page indirect
  330.   : $55 zpx. doEOR ; \ zero page,X
  331.   : $4D abs. doEOR ; \ absolute
  332.   : $5D abx. doEOR ; \ absolute,X
  333.   : $59 aby. doEOR ; \ absolute,Y
  334.   : $41 inx. doEOR ; \ indirect,X
  335.   : $51 iny. doEOR ; \ indirect,Y
  336.  
  337. \ INC - Increment Memory by One
  338.  
  339.   : doINC 1+
  340.      dup 100 = if drop 0 then 
  341.      dup 0= if #Z set else #Z unset then
  342.      dup 7F > if #N set else #N unset then
  343.      addr @ $! ;
  344.  
  345.   : $E6 zpg. doINC ;
  346.   : $F6 zpx. doINC ;
  347.   : $EE abs. doINC ;
  348.   : $FE abx. doINC ;
  349.  
  350. \ INA - Increment A by one
  351.  
  352.   : $1A A @ 1+
  353.      dup 100 = if drop 0 A ! 0 then 
  354.      dup 0= if #Z set else #Z unset then
  355.      dup 7F > if #N set else #N unset then
  356.      A ! ;    
  357.  
  358. \ INX - Increment X by one
  359.  
  360.   : $E8 X @ 1+
  361.      dup 100 = if drop 0 X ! 0 then 
  362.      dup 0= if #Z set else #Z unset then
  363.      dup 7F > if #N set else #N unset then
  364.      X ! ;    
  365.  
  366. \ INY - Increment Y by one
  367.  
  368.   : $C8 Y @ 1+
  369.      dup 100 = if drop 0 Y ! 0 then 
  370.      dup 0= if #Z set else #Z unset then
  371.      dup 7F > if #N set else #N unset then
  372.      Y ! ;    
  373.  
  374. \ JMP - Jump
  375.  
  376.   : $4C fetch fetch 100 * + PC ! ;
  377.   : $6C fetch fetch 100 * + dup 1+ $@ swap $@ swap 100 * + PC ! ;
  378.   : $7C fetch fetch 100 * + X @ + dup 1+ $@ swap $@ swap 100 * + PC ! ;
  379.  
  380. \ JSR - Jump to subroutine
  381.  
  382.   : $20 fetch fetch pushPC >addr PC ! ;
  383.   
  384. \ LDA - Load the Accumulator
  385.  
  386.   : psLDA 
  387.       dup 0= if #Z set else #Z unset then
  388.         7F > if #N set else #N unset then ;
  389.   
  390.   : doLDA   dup psLDA A !  ;
  391.   
  392.   : $A9 imm. doLDA ; \ immediate
  393.   : $A5 zpg. doLDA ; \ zero page
  394.   : $B2 zpi. doLDA ; \ zero page indirect
  395.   : $B5 zpx. doLDA ; \ zero page,X
  396.   : $AD abs. doLDA ; \ absolute
  397.   : $BD abx. doLDA ; \ absolute,X
  398.   : $B9 aby. doLDA ; \ absolute,Y
  399.   : $A1 inx. doLDA ; \ indirect,X
  400.   : $B1 iny. doLDA ; \ indirect,Y
  401.   
  402. \ LDX - Load the X register
  403.  
  404.   : psLDX
  405.       dup 0= if #Z set else #Z unset then
  406.         7F > if #N set else #N unset then ;
  407.  
  408.   : doLDX  dup psLDX X !  ;
  409.   
  410.   : $A2 imm. doLDX ;                   \ immediate
  411.   : $A6 zpg. doLDX ;                    \ zero page
  412.   : $B6 fetch Y @ + $@ doLDX ;           \ zero page,Y
  413.   : $AE abs. doLDX ;                      \ absolute
  414.   : $BE fetch fetch >addr Y @ + $@ doLDX ; \ absolute,Y
  415.   
  416. \ LDY - Load the Y register
  417.  
  418.   : psLDY
  419.       dup 0= if #Z set else #Z unset then
  420.         7F > if #N set else #N unset then ;
  421.  
  422.   : doLDY  dup psLDY Y !  ;
  423.   
  424.   : $A0 imm. doLDY ; \ immediate
  425.   : $A4 zpg. doLDY ; \ zero page
  426.   : $B4 zpx. doLDY ; \ zero page,X
  427.   : $AC abs. doLDY ; \ absolute
  428.   : $BC abx. doLDY ; \ absolute,X
  429.  
  430. \ LSR - Shift right
  431.  
  432.   : psLSR 
  433.       dup 1 and #C v! 2/
  434.       dup 0= if #Z set else #Z unset then
  435.       #N unset ;
  436.   
  437.   : $4A A @  psASL A !  ;      \ accumulator
  438.   : $46 zpg. psASL addr @ $! ; \ zero page
  439.   : $56 zpx. psASL addr @ $! ; \ zero page,X
  440.   : $4E abs. psASL addr @ $! ; \ absolute
  441.   : $5E abx. psASL addr @ $! ; \ absolute,X
  442.  
  443. \ NOP - No Operation
  444.  
  445.   : $EA ;
  446.   
  447. \ ORA - OR memory with Accumulator
  448.  
  449.   : psORA 
  450.      dup 0= if #Z set else #Z unset then \ zero
  451.      7F > if #N set else #N unset then  ; \ negative
  452.   
  453.   : doORA   A @ or dup A ! psORA  ;
  454.   
  455.   : $09 imm. doORA ; \ immediate
  456.   : $05 zpg. doORA ; \ zero page
  457.   : $12 zpi. doORA ; \ zero page indirect
  458.   : $15 zpx. doORA ; \ zero page,X
  459.   : $0D abs. doORA ; \ absolute
  460.   : $1D abx. doORA ; \ absolute,X
  461.   : $19 aby. doORA ; \ absolute,Y
  462.   : $01 inx. doORA ; \ indirect,X
  463.   : $11 iny. doORA ; \ indirect,Y
  464.  
  465. \ PHA - Push Accumulator on Stack
  466.  
  467.   : $48 A @ push ;
  468.   
  469. \ PHP - Push Processor Status on Stack
  470.  
  471.   : $08 
  472.     #N @v 80 *  #V @v 40 * +  #D @v 8 * +  #I @v 4 * +  #Z @v 2 * + #C @v +
  473.     push ;
  474.     
  475. \ PHX - Push X on Stack
  476.  
  477.   : $DA X @ push ;
  478.   
  479. \ PHY - Push Y on Stack
  480.  
  481.   : $5A Y @ push ;
  482.  
  483. \ PLA - Pull A from Stack
  484.  
  485.   : $68 pull dup A ! psORA ;  \ call psORA to set the flags
  486.   
  487. \ PLP - Pull processor status from Stack
  488.  
  489.   : $28 pull 
  490.       dup 80 and 0= if #N unset else #N set then
  491.       dup 40 and 0= if #V unset else #V set then
  492.       dup  8 and 0= if #D unset else #D set then
  493.       dup  4 and 0= if #I unset else #I set then
  494.       dup  2 and 0= if #Z unset else #Z set then
  495.            1 and 0= if #C unset else #C set then
  496.    ;
  497.   
  498. \ PLX - Pull X from stack
  499.  
  500.   : $FA pull dup X ! psORA ;  \ as in PLA
  501.   
  502. \ PLY - Pull Y from stack
  503.  
  504.   : $7A pull dup Y ! psORA ;  \ as in PLA
  505.  
  506. \ ROL - Rotate Accumulator or Memory left
  507.  
  508.   : psROL 
  509.       dup FF > if 100 - #C set else #C unset then
  510.       dup 0= if #Z set else #Z unset then
  511.       dup 7F > if #N set else #N unset then ;
  512.   
  513.   : doROL  2 * #C @v + psROL  ;
  514.   
  515.   : $2A A @  doROL A !       ; \ accumulator
  516.   : $26 zpg. doROL addr @ $! ; \ zero page
  517.   : $36 zpx. doROL addr @ $! ; \ zero page,X
  518.   : $2E abs. doROL addr @ $! ; \ absolute
  519.   : $3E abx. doROL addr @ $! ; \ absolute,X
  520.  
  521. \ ROR - Rotate Accumulator or Memory right
  522.  
  523.   : psROR
  524.       dup 0= if #Z set else #Z unset then
  525.       dup 7F > if #N set else #N unset then ;      
  526.   
  527.   : doROR  dup 1 and swap 2/ #C @v 80 * + swap #C v! psROR  ;
  528.   
  529.   : $6A A @  doROR A !       ; \ accumulator
  530.   : $66 zpg. doROR addr @ $! ; \ zero page
  531.   : $76 zpx. doROR addr @ $! ; \ zero page,X
  532.   : $6E abs. doROR addr @ $! ; \ absolute
  533.   : $7E abx. doROR addr @ $! ; \ absolute,X
  534.  
  535. \ RTI - Return from Interrupt
  536.  
  537.   : $40 ;  \ interrupts not enabled
  538.   
  539. \ RTS - Return from subroutine
  540.  
  541.   : $60 pull pull >addr 1+ PC ! ;
  542.  
  543. \ SBC - Subtract from Accumulator with Carry
  544.  
  545.   : psSBC ( v -- )
  546.       >r r@ 0 < if r@ 100 + A ! #C unset else #C set then  \ carry
  547.       r@ 0= if #Z set else #Z unset then    \ zero
  548.       r@ 7F > if #N set else #N unset then \ negative
  549.       r> 80 and oldA @ 80 and <> if #V set else #V unset then \ overflow
  550.   ; 
  551.   
  552.   : doSBC  
  553.        A @ dup oldA ! swap - #C @v 1 xor - dup A ! psSBC 
  554.   ;   
  555.     
  556.   : $E9 imm. doSBC ; \ immediate
  557.   : $E5 zpg. doSBC ; \ zero page
  558.   : $F2 zpi. doSBC ; \ zero page indirect
  559.   : $F5 zpx. doSBC ; \ zero page,X
  560.   : $ED abs. doSBC ; \ absolute
  561.   : $FD abx. doSBC ; \ absolute,X
  562.   : $F9 aby. doADC ; \ absolute,Y
  563.   : $E1 inx. doADC ; \ indirect,X
  564.   : $F1 iny. doADC ; \ indirect,Y
  565.  
  566. \ SEC - Set Carry Flag
  567.  
  568.   : $38 #C set ;
  569.   
  570. \ SED - Set Decimal Mode
  571.  
  572.   : $F8 #D set 
  573.      ." Warning! Decimal mode set but not currently implemented." cr ;
  574.   
  575. \ SEI - Set Interrupt Disable
  576.  
  577.   : $78 ;  \ interrupts are not enabled
  578.   
  579. \ STA - Store Accumulator in Memory
  580.  
  581.   : doSTA  drop A @ addr @ $!  ;
  582.  
  583.   : $85 zpg. doSTA ; \ zero page
  584.   : $92 zpi. doSTA ; \ zero page indirect
  585.   : $95 zpx. doSTA ; \ zero page,X
  586.   : $8D abs. doSTA ; \ absolute
  587.   : $9D abx. doSTA ; \ absolute,X
  588.   : $99 aby. doSTA ; \ absolute,Y
  589.   : $81 inx. doSTA ; \ indirect,X
  590.   : $91 iny. doSTA ; \ indirect,Y
  591.   
  592. \ STX - Store X in Memory
  593.  
  594.   : $86 zpg. drop X @ addr @ $! ; \ zero page
  595.   : $96 X @ fetch Y @ + $! ; \ zero page,Y
  596.   : $8E abs. drop X @ addr @ $! ; \ absolute
  597.   
  598. \ STY - Store Y in Memory
  599.  
  600.   : $84 zpg. drop Y @ addr @ $! ; \ zero page
  601.   : $94 zpx. drop Y @ addr @ $! ; \ zero page,X
  602.   : $8C abs. drop Y @ addr @ $! ; \ absolute
  603.   
  604. \ TAX - Transfer Accumulator to Index X
  605.  
  606.   : $AA A @ dup X ! dup 0= if #Z set else #Z unset then
  607.         7F > if #N set else #N unset then ;
  608.         
  609. \ TAY - Transfer Accumulator to Index Y
  610.  
  611.   : $A8 A @ dup Y ! dup 0= if #Z set else #Z unset then
  612.         7F > if #N set else #N unset then ;
  613.  
  614. \ TSX - Transfer stack pointer to X
  615.  
  616.   : $BA S @ 100 - dup X ! dup 0= if #Z set else #Z unset then
  617.         7F > if #N set else #N unset then ;
  618.         
  619. \ TXA - Transfer X to A
  620.  
  621.   : $8A X @ dup A ! dup 0= if #Z set else #Z unset then
  622.         7F > if #N set else #N unset then ;
  623.  
  624. \ TXS - Transfer X to Stack
  625.  
  626.   : $9A X @ 100 + S ! ;
  627.   
  628. \ TYA - Transfer Y to A
  629.  
  630.   : $98 Y @ dup A ! dup 0= if #Z set else #Z unset then
  631.         7F > if #N set else #N unset then ;
  632.  
  633. \ STZ - Store zero
  634.  
  635.   : $9C abs. drop 0 addr @ $! ; \ absolute
  636.   : $9E abx. drop 0 addr @ $! ; \ absolute,X
  637.   : $64 zpg. drop 0 addr @ $! ; \ zerlen -- ec ) ; \                                  ****
  638.  
  639.   : bytesReadf0 ; \ return number of bytes read during last read   ****
  640.   : bytesReadf1 ; \                                                ****
  641.   : bytesReadf2 ; \                                                ****
  642.    
  643.   : fill&clear \ fill buffer with $20 and clear high bits to speed
  644.                \ loading.
  645.     \ fill remainder of buffer with spaces
  646.     2000  bytesReadf0 1000 + do
  647.       20 i $!
  648.     loop
  649.     \ clear the hi-bit of the data
  650.     2000 1000 do
  651.       i $@ 7F and i $!
  652.     loop   
  653.   ;
  654.   
  655.   : pdCA \ read bytes
  656.      paramAddr 2+ c@  paramAddr 3 + c@ 100 * + $0000 + \ address of buffer
  657.      paramAddr 4 + c@ paramAddr 5 + c@ 100 * + \ requested length
  658.      paramAddr 1+ c@  \ reference number
  659.      dup 0= if drop readf0 else
  660.      dup 1 = if drop readf1 else  \ read appropriate file
  661.      dup 2 = if drop readf2 else
  662.          drop readf0 then then then
  663.      err  \ handle error code
  664.      paramAddr 1+ c@
  665.      dup 0=  if drop bytesReadf0 else
  666.      dup 1 = if drop bytesReadf1 else  \ fill in bytes read
  667.      dup 2 = if drop bytesReadf2 else
  668.          drop bytesReadf0 then then then
  669.      pushT !
  670.      pushT 3 + c@  paramAddr 6 + c!  \ lo
  671.      pushT 2+ c@  paramAddr 7 + c!  \ hi
  672.      paramAddr 1+ c@ 3 = if fill&clear then  \ set up for 'read'
  673.   ;
  674.   
  675.   : writef0 ( addr len -- ) ; \ write len bytes from addr to file 0  ****
  676.   : writef1 ; \                                                      ****
  677.   : writef2 ; \                                                      ****
  678.   
  679.   : pdCB \ write bytes
  680.      paramAddr 2+ c@  paramAddr 3 + c@ 100 * + $0000 + \ address of buffer
  681.      paramAddr 4 + c@ paramAddr 5 + c@ 100 * + \ requested length
  682.      paramAddr 1+ c@  \ reference number
  683.      dup 0= if drop writef0 else
  684.      dup 1 = if drop writef1 else  \ read appropriate file
  685.          drop writef2 then then
  686.      err  \ handle error code
  687.      paramAddr 4 + c@  paramAddr 6 + c!  \ lo   bytes written = bytes requested
  688.      paramAddr 5 + c@  paramAddr 7 + c!  \ hi
  689.   ;
  690.   
  691.   : closef0 ;  \ close file 0                                     ****
  692.   : closef1 ;  \                                                  ****
  693.   : closef2 ;  \                                                  ****
  694.   
  695.   : pdCC \ close a file
  696.      paramAddr 1+ c@  \ reference number
  697.      dup 0=  if drop closef0 else
  698.      dup 1 = if drop closef1 else  \ close the file
  699.          2 = if      closef2 else 
  700.      closef0 then then then \ 'read' uses reference number 3
  701.      err \ return code to A
  702.   ;
  703.   
  704.   : moveTof0 ( byte# -- ec ) ;  \ move file 0 pointer to byte #    ****
  705.   : moveTof1 ; \                                                   ****
  706.   : moveTof2 ; \                                                   ****
  707.   
  708.   : pdCE \ set file position
  709.      paramAddr 4 + c@ 10000 * \ file position
  710.      paramAddr 3 + c@ 100 * +
  711.      paramAddr 2+ c@ +
  712.      paramAddr 1+ c@  \ reference number
  713.      dup 0=  if drop moveTof0 else
  714.      dup 1 = if drop moveTof1 else  \ position
  715.                 drop moveTof2 then then
  716.      err 
  717.   ;
  718.  
  719. : $FF 
  720.     pull pull >addr 1+ dup >r $@ func !  \ get command code
  721.     r@ 1+ $@ r@ 2+ $@ 100 * + params !      \ get parameter table address
  722.     r> 3 + PC !                             \ set PC to next instruction
  723.     
  724.     \ do the command
  725.     
  726.     func @
  727.     dup C0 = if drop pdC0 else  \ create
  728.     dup C1 = if drop pdC1 else  \ destroy
  729.     dup C4 = if drop pdC4 else  \ info
  730.     dup C8 = if drop pdC8 else  \ open
  731.     dup CA = if drop pdCA else  \ read
  732.     dup CB = if drop pdCB else  \ write
  733.     dup CC = if drop pdCC else  \ close
  734.     dup CE = if drop pdCE else  \ position
  735.     dup 65 = if drop bye  else  \ bye, quit program
  736.      ." ProDOS MLI error: Unknown function, code = " . cr quit
  737.     then then then then then then then then then
  738.     A @ 0= if #C unset #Z set else #C set #Z unset then \ signal an error
  739.     \ PC already set properly, so just return
  740. ;
  741.  
  742.  
  743. \ Monitor routines and locations
  744.  
  745. : $DB  \ trap CH word, set horizontal position
  746.    Y @ \ set horizontal cursor position to the value in Y           ****
  747. ;
  748.  
  749. : $DF  \ trap CV word, set vertical position
  750.    Y @ \ set vertical cursor position to the value in Y             ****
  751. ;
  752.  
  753. : $E7  \ trap $C300 - clear the screen
  754.   page ;
  755.  
  756. : del \ handle a backspace or delete character
  757.    8 emit  \ should work on most terminals                          ****
  758. ;
  759.  
  760. : 80? ; \ true if cursor position at 80                             ****
  761.  
  762. : $F3  \ cout - output character in A
  763.    80? if cr then  \ newline if 80 characters out on this line
  764.    A @ 7F and \ QForth sets hi bit, clear it
  765.    dup 7F = if drop del else    \ delete
  766.    dup 08 = if drop del else     \ backspace
  767.    dup 0d = if drop space cr else \ return
  768.    dup 1F > if emit else drop      \ alphanumeric
  769.    then then then then
  770. ;
  771.  
  772. : .r ( n d -- ) \                                                   ****  
  773.     drop . ; \ print n in justified in d spaces in current base
  774.  
  775. : $C7 \ hex - output character in A as two hex digits
  776.    @xy drop 1E8 = if cr then 
  777.    A @ 10 < if 30 emit A @ 1 .r else A @ 2 .r then
  778. ;
  779.  
  780. : random ( n -- m )  0 ; \ return a random number from 0 to n-1     ****
  781.  
  782. : $CB \ put a random number in FF8E and FF8F
  783.    100 random FF8F $! 100 random FF8E $! ;
  784.  
  785. : $F7 \ output a cr
  786.     space cr ;
  787.  
  788. : $FB \ get a key to A
  789.    key 80 or A ! ;
  790.  
  791. : depthQF \ depth of QForth stack
  792.    F4 $@ ;
  793.  
  794. variable xGR  \ hold current graphics coordinates
  795. variable yGR
  796.  
  797. : gotoxy ( x y -- ) ; \ move drawing pen to x,y                    ****
  798. : lineto ( x y -- ) ; \ line from current position to x,y          ****
  799.  
  800. : putPen   \ restore graphics pen position
  801.    xGR @  yGR @  gotoxy ;
  802.  
  803. : savePen  \ store graphics pen position
  804.    @xy yGR ! xGR ! ;
  805.  
  806. : $EB \ LineTo
  807.    depthQF 1 > if  \ at least two values
  808.      @xy  putPen  \ save current position and move to old graphics position
  809.      popQF popQF swap lineto  \ move
  810.      savePen gotoxy  \ store new graphics position
  811.    then
  812. ;
  813.  
  814. : $EF \ MoveTo
  815.    depthQF 1 > if
  816.      @xy  putPen
  817.      popQF popQF swap gotoxy
  818.      savePen gotoxy
  819.    then
  820. ;
  821.  
  822. : red     ;  \ set the appropriate drawing color                 ****
  823. : black   ;  \                                                   ****
  824. : yellow  ;  \                                                   ****
  825. : green   ;  \                                                   ****
  826. : blue    ;  \                                                   ****
  827. : white   ;  \                                                   ****
  828. : cyan    ;  \                                                   ****
  829. : magenta ;  \                                                   ****
  830.  
  831. : $E3 \ set drawing color
  832.    depthQF 0 > if
  833.      popQF
  834.      dup 0 = if drop black else
  835.      dup 1 = if drop red   else
  836.      dup 2 = if drop green else
  837.      dup 3 = if drop blue  else
  838.      dup 4 = if drop cyan  else
  839.      dup 5 = if drop magenta else
  840.      dup 6 = if drop yellow else
  841.          7 = if drop white  else
  842.      black then then then then then then
  843.      then then then
  844. ;
  845.  
  846. : $D7 \ plot a point, faster than using QForth code
  847.    depthQF 1 > if
  848.      @xy popQF dup yGR ! popQF dup xGR ! swap
  849.      2dup gotoxy lineto
  850.      gotoxy
  851.    then
  852. ;
  853.  
  854. : $D3 \ get mouse position and button status                         ****
  855.    \ get mouse position and button status (0,-1)
  856.    0= if 0 pushQF else FFFF pushQF then \ push button status on stack   
  857. ;
  858.  
  859. \ Section: System Monitor
  860.  
  861. \
  862. \ System monitor - $FFF0
  863. \
  864.  
  865. : 'type ; \ read the next word and compile the characters in to a single
  866.   \ 32-bit word with a space at the end.  Something needs to be done 
  867.   \ here for 16-bit Forths.
  868.   \
  869.   \ ex.  'type ABC  should return 41424320                           ****
  870.  
  871. variable buff 4C allot \ a small input buffer
  872.  
  873. 'type ADC  variable mnemonics \ table of instruction names
  874. 'type AND  , 'type ASL  , 'type BCC  , 'type BCS  , 'type BEQ  , 
  875. 'type BIT  , 'type BMI  , 'type BNE  , 'type BPL  , 'type BRA  , 
  876. 'type BRK  , 'type BVC  , 'type BVS  , 'type CLC  , 'type CLD  , 
  877. 'type CLI  , 'type CLV  , 'type CMP  , 'type CPX  , 'type CPY  , 
  878. 'type DEA  , 'type DEC  , 'type DEX  , 'type DEY  , 'type EOR  , 
  879. 'type INA  , 'type INC  , 'type INX  , 'type INY  , 'type JMP  , 
  880. 'type JSR  , 'type LDA  , 'type LDX  , 'type LDY  , 'type LSR  , 
  881. 'type NOP  , 'type ORA  , 'type PHA  , 'type PHP  , 'type PHX  , 
  882. 'type PHY  , 'type PLA  , 'type PLP  , 'type PLX  , 'type PLY  , 
  883. 'type ROL  , 'type ROR  , 'type RTI  , 'type RTS  , 'type SBC  , 
  884. 'type SEC  , 'type SED  , 'type SEI  , 'type STA  , 'type STX  , 
  885. 'type STY  , 'type STZ  , 'type TAX  , 'type TAY  , 'type TRB  , 
  886. 'type TSB  , 'type TSX  , 'type TXA  , 'type TXS  , 'type TYA  , 
  887. 'type ???  ,
  888.  
  889. \ listing table, each entry is 4 bytes long <00><00><instruction#><mode>
  890.  
  891. \ 16-bit Forths are okay here, but need to modify access word below
  892.  
  893. \ <mode>=  00 - implied,    1 byte
  894. \          01 - immediate,  2 byte
  895. \          02 - absolute,   3 byte
  896. \          03 - zero page,  2 byte
  897. \          04 - ABS,X,      3 byte
  898. \          05 - ZPG,X,      2 byte
  899. \          06 - (IND,X),    2 byte
  900. \          07 - ABS(IND,X), 3 byte
  901. \          08 - (IND),Y,    2 byte
  902. \          09 - (ZPG),      2 byte
  903. \          0A - (ABS),      3 byte
  904. \          0B - ABS,Y,      3 byte
  905. \          0C - ZPG,Y,      2 byte
  906.  
  907.  
  908. variable list  0C00 list !
  909. 2606 , 4300 , 4300 , 3E03 , 2603 , 0303 , 4300 , 2800 , 2601 , 0300 ,
  910. 4300 , 3E02 , 2602 , 0302 , 4300 ,        \ row 00
  911.  
  912. 0A01 , 2608 , 2609 , 4300 , 3D03 , 2606 , 0306 , 4300 , 0F00 , 260B ,
  913. 1B00 , 4300 , 3D02 , 2604 , 0304 , 4300 , \ row 01
  914.  
  915. 2002 , 0206 , 4300 , 4300 , 0703 , 0203 , 2F03 , 4300 , 2C00 , 0201 ,
  916. 2F00 , 4300 , 0702 , 0202 , 2F02 , 4300 , \ row 02
  917.  
  918. 0801 , 0208 , 0209 , 4300 , 0705 , 0205 , 2F05 , 4300 , 3400 , 020B ,
  919. 1600 , 4300 , 0704 , 0204 , 2F04 , 4300 , \ row 03
  920.  
  921. 3100 , 1A06 , 4300 , 4300 , 4300 , 1A03 , 2403 , 4300 , 2700 , 1A01 ,
  922. 2400 , 4300 , 1F02 , 1A02 , 2402 , 4300 , \ row 04
  923.  
  924. 0D01 , 1A08 , 1A09 , 4300 , 4300 , 1A05 , 2405 , 4300 , 1100 , 1A0B ,
  925. 2A00 , 4300 , 4300 , 1A04 , 2404 , 4300 , \ row 05
  926.  
  927. 3200 , 0106 , 4300 , 4300 , 3A03 , 0103 , 3003 , 4300 , 2B00 , 0101 ,
  928. 3000 , 4300 , 1F0A , 0102 , 3002 , 4300 , \ row 06
  929.  
  930. 0E01 , 0106 , 0109 , 4300 , 3A05 , 0105 , 3005 , 4300 , 3600 , 010B ,
  931. 2E00 , 4300 , 1F07 , 0104 , 3004 , 4300 , \ row 07
  932.  
  933. 0B01 , 3706 , 4300 , 4300 , 3903 , 3703 , 3803 , 4300 , 1900 , 0701 ,
  934. 4000 , 4300 , 3902 , 3702 , 3802 , 4300 , \ row 08
  935.  
  936. 0401 , 3708 , 3709 , 4300 , 3905 , 3705 , 380C , 4300 , 4200 , 370B ,
  937. 4100 , 4300 , 3A02 , 3704 , 3A04 , 4300 , \ row 09
  938.  
  939. 2301 , 2106 , 2201 , 4300 , 2303 , 2103 , 2203 , 4300 , 3C00 , 2101 ,
  940. 3B00 , 4300 , 2302 , 2102 , 2202 , 4300 , \ row 0A
  941.  
  942. 0501 , 2108 , 2109 , 4300 , 2305 , 2105 , 220C , 4300 , 1200 , 210B ,
  943. 3F00 , 4300 , 2304 , 2104 , 220B , 4300 , \ row 0B
  944.  
  945. 1501 , 1306 , 4300 , 4300 , 1503 , 1303 , 1703 , 4300 , 1E00 , 1301 ,
  946. 1800 , 4300 , 1502 , 1302 , 1702 , 4300 , \ row 0C
  947.  
  948. 0901 , 1308 , 1309 , 4300 , 4300 , 1305 , 1705 , 4300 , 1000 , 130B ,
  949. 2900 , 4300 , 4300 , 1304 , 1704 , 4300 , \ row 0D
  950.  
  951. 1401 , 3306 , 4300 , 4300 , 1403 , 3303 , 1C03 , 4300 , 1D00 , 3301 ,
  952. 2500 , 4300 , 1402 , 3302 , 1C02 , 4300 , \ row 0E
  953.  
  954. 0601 , 3308 , 3309 , 4300 , 4300 , 3305 , 1C05 , 4300 , 3500 , 330B ,
  955. 2D00 , 4300 , 4300 , 3304 , 1C04 , 4300 , \ row 0F 
  956.  
  957. : uppercase \ make a character uppercase
  958.    dup dup 60 > swap 7B < and if 20 - then ;
  959.  
  960. : chars ( buff maxlen -- length ) \ returns the length of the line
  961.    0 do dup i + c@ 0= if drop i FF else 1 then +loop ;
  962.  
  963. variable buff2 4C allot \ temporary buffer   
  964. variable k  \ index
  965. : killSpaces \ remove spaces from the input line
  966.    0 k !
  967.    buff 50 chars 1+ 0 do
  968.      buff i + c@ dup 20 <> if
  969.        uppercase buff2 k @ + c!  \ save in temporary buffer
  970.        k @ 1+ k !      \ increment k
  971.      else drop then
  972.    loop
  973.    buff2 50 chars 1+ 0 do
  974.      buff2 i + c@  buff i + c!  \ put in original buffer
  975.    loop ; 
  976.  
  977. variable num 4C allot \ conversion buffer
  978. variable endchar \ stop character
  979. variable buffaddr \ buffer address
  980. : getNumber ( addr end-char -- n ) \ make a string a number
  981.    1 k ! \ use k defined above in killSpaces
  982.    20 num c! \ initial blank
  983.    endchar ! buffaddr ! \ save end character and buffer address
  984.    begin
  985.      buffaddr @ c@ endchar @ <>  \ haven't reached match character
  986.    while
  987.      buffaddr @ c@ uppercase
  988.      num k @ + c!                \ copy character to num
  989.      buffaddr @ 1+ buffaddr !     \ increment buffer pointer
  990.      k @ 1+ k !                    \ and index pointer
  991.    repeat
  992.    20 num k @ + c!  \ add final blank
  993.     0 num k @ 1+ + c! \ and null
  994.    
  995.    \ convert the string <bl><text><bl> in num to a number    ****
  996.    
  997. ;    
  998.  
  999. variable lines    \ number of lines listed
  1000. variable listAddr \ address
  1001. variable aLabel    \ holds a compressed label
  1002.  
  1003. : printLabel   \ print an instruction label
  1004.   1- 4 * mnemonics + @ \ get the label 
  1005.   aLabel !             \ save it
  1006.   aLabel c@ emit aLabel 1+ c@ emit aLabel 2+ c@ emit \ print it
  1007.   space ;
  1008.  
  1009. : instSize  \ return instruction size in bytes
  1010.     dup 0 = if drop 1 else \ implied
  1011.     dup 1 = if drop 2 else \ immediate
  1012.     dup 2 = if drop 3 else \ absolute
  1013.     dup 3 = if drop 2 else \ zero page
  1014.     dup 4 = if drop 3 else \ abs,x
  1015.     dup 5 = if drop 2 else \ zpg,x
  1016.     dup 6 = if drop 2 else \ ind,x
  1017.     dup 7 = if drop 3 else \ abs(ind,x)
  1018.     dup 8 = if drop 2 else \ (ind),y
  1019.     dup 9 = if drop 2 else \ (zpg)
  1020.     dup A = if drop 3 else \ (abs)
  1021.     dup B = if drop 3 else \ abs,y
  1022.         C = if      2 else \ zpg,y
  1023.     1 then then then then then then then then then then then then then 
  1024. ;
  1025.  
  1026. : .$ ( num size -- ) \ print num as a size hex number
  1027.    \ assumes size is either 2 or 4
  1028.    2 = if
  1029.      dup 10 < if 30 emit 1 .r else 2 .r then
  1030.    else
  1031.      dup   10 < if 30 emit 30 emit 30 emit 1 .r else
  1032.      dup  100 < if 30 emit 30 emit 2 .r else
  1033.      dup 1000 < if 30 emit 3 .r else 4 .r then then then
  1034.    then ;
  1035.    
  1036. : outHex ( size -- ) \ output hex data
  1037.    listAddr @ $@ 2 .$ space  \ all are at least one byte
  1038.    dup 1 = if drop space space space  space space else
  1039.    dup 2 = if  drop          \ two bytes
  1040.      listAddr @ 1+ $@ 2 .$
  1041.      space space space
  1042.    else
  1043.      3 = if                  \ three bytes
  1044.      listAddr @ 1+ $@ 2 .$ space
  1045.      listAddr @ 2+ $@ 2 .$
  1046.      then
  1047.    then then
  1048.    space ;
  1049.  
  1050. variable b1 \ first data byte
  1051. variable b2 \ second data byte   
  1052.  
  1053. : .b @ 2 .$ ; \ print a data byte
  1054.  
  1055. : .imm 23 emit 24 emit b1 .b ;                               \ immediate
  1056. : .abs 24 emit b2 .b b1 .b   ;                               \ absolute
  1057. : .zpg 24 emit b1 .b         ;                               \ zero page
  1058. : .abx 24 emit b2 .b b1 .b 2C emit 58 emit ;                 \ absolute,x
  1059. : .zpx 24 emit b1 .b 2C emit 58 emit ;                       \ zero page,x
  1060. : .zix 28 emit 24 emit b1 .b 2C emit 58 emit 29 emit ;       \ ($33,X)
  1061. : .aix 28 emit 24 emit b2 .b b1 .b 2C emit 58 emit 29 emit ; \ ($FDED,X)
  1062. : .ziy 28 emit 24 emit b1 .b 29 emit 2C emit 59 emit ;       \ ($33),Y
  1063. : .zpi 28 emit 24 emit b1 .b 29 emit ;                       \ ($33)
  1064. : .abi 28 emit 24 emit b2 .b b1 .b 29 emit ;                 \ ($FDED)
  1065. : .aby 24 emit b2 .b b1 .b 2C emit 59 emit ;                 \ $FDED,Y
  1066. : .zpy 24 emit b1 .b 2C emit 59 emit ;                       \ $33,Y
  1067.  
  1068. : printMode ( mode -- ) \ output instruction data
  1069.    listAddr @ 1+ $@ b1 !  listAddr @ 2+ $@ b2 ! \ save data bytes
  1070.    dup 0 = if drop      else \ implied
  1071.    dup 1 = if drop .imm else \ immediate
  1072.    dup 2 = if drop .abs else \ absolute
  1073.    dup 3 = if drop .zpg else \ zero page
  1074.    dup 4 = if drop .abx else \ absolute,x
  1075.    dup 5 = if drop .zpx else \ zero page,x
  1076.    dup 6 = if drop .zix else \ zero page indirect x
  1077.    dup 7 = if drop .aix else \ absolute indirect x
  1078.    dup 8 = if drop .ziy else \ zero page indirect y
  1079.    dup 9 = if drop .zpi else \ zero page indirect
  1080.    dup A = if drop .abi else \ absolute indirect
  1081.    dup B = if drop .aby else \ absolute y
  1082.        C = if drop .zpy else \ zero page y
  1083.    then then then then then then then then then then then 
  1084.    then then
  1085. ;
  1086.  
  1087. : listMem                                       \ 'L' - list memory
  1088.    buff 1+ c@ 0 <> if
  1089.      buff 1+ 0 getNumber  listAddr !
  1090.    then
  1091.    0 lines !
  1092.    begin 
  1093.      lines @ 16 <
  1094.    while
  1095.      listAddr @ 4 .$ 2D emit space \ print address
  1096.      listAddr @ $@ 4 * list + 3 + c@  \ get mode           (2 * 16-bit) ****
  1097.      instSize outHex                 \ print hex codes
  1098.      listAddr @ $@ 4 * list + 2+ c@    \ get instruction  (2 *)
  1099.      printLa ' $00 ,   \ 60
  1100. ' $64 ,    ' $65 ,    ' $66 ,    ' $00 ,   \ 64
  1101. ' $68 ,    ' $69 ,    ' $6A ,    ' $00 ,   \ 68
  1102. ' $6C ,    ' $6D ,    ' $6E ,    ' $00 ,   \ 6C
  1103. ' $70 ,    ' $71 ,    ' $72 ,    ' $00 ,   \ 70
  1104. ' $74 ,    ' $75 ,    ' $76 ,    ' $00 ,   \ 74
  1105. ' $78 ,    ' $79 ,    ' $7A ,    ' $00 ,   \ 78
  1106. ' $7C ,    ' $7D ,    ' $7E ,    ' $00 ,   \ 7C
  1107. ' $80 ,    ' $81 ,    ' $00 ,    ' $00 ,   \ 80
  1108. ' $84 ,    ' $85 ,    ' $86 ,    ' $00 ,   \ 84
  1109. ' $88 ,    ' $89 ,    ' $8A ,    ' $00 ,   \ 88
  1110. ' $8C ,    ' $8D ,    ' $8E ,    ' $00 ,   \ 8C
  1111. ' $90 ,    ' $91 ,    ' $92 ,    ' $00 ,   \ 90
  1112. ' $94 ,    ' $95 ,    ' $96 ,    ' $00 ,   \ 94
  1113. ' $98 ,    ' $99 ,    ' $9A ,    ' $00 ,   \ 98
  1114. ' $9C ,    ' $9D ,    ' $9E ,    ' $00 ,   \ 9C
  1115. ' $A0 ,    ' $A1 ,    ' $A2 ,    ' $00 ,   \ A0
  1116. ' $A4 ,    ' $A5 ,    ' $A6 ,    ' $00 ,   \ A4
  1117. ' $A8 ,    ' $A9 ,    ' $AA ,    ' $00 ,   \ A8
  1118. ' $AC ,    ' $AD ,    ' $AE ,    ' $00 ,   \ AC
  1119. ' $B0 ,    ' $B1 ,    ' $B2 ,    ' $00 ,   \ B0
  1120. ' $B4 ,    ' $B5 ,    ' $B6 ,    ' $00 ,   \ B4
  1121. ' $B8 ,    ' $B9 ,    ' $BA ,    ' $00 ,   \ B8
  1122. ' $BC ,    ' $BD ,    ' $BE ,    ' $00 ,   \ BC
  1123. ' $C0 ,    ' $C1 ,    ' $00 ,    ' $C3 ,   \ C0, C3 = set startup word
  1124. ' $C4 ,    ' $C5 ,    ' $C6 ,    ' $C7 ,   \ C4, C7 = hex output trap
  1125. ' $C8 ,    ' $C9 ,    ' $CA ,    ' $CB ,   \ C8, CB = random number
  1126. ' $CC ,    ' $CD ,    ' $CE ,    ' $CF ,   \ CC, CF = "system monitor"
  1127. ' $D0 ,    ' $D1 ,    ' $D2 ,    ' $D3 ,   \ D0, D3 = mouse
  1128. ' $00 ,    ' $D5 ,    ' $D6 ,    ' $D7 ,   \ D4, D7 = plot
  1129. ' $D8 ,    ' $D9 ,    ' $DA ,    ' $DB ,   \ D8, DB = CH trap
  1130. ' $00 ,    ' $DD ,    ' $DE ,    ' $DF ,   \ DC, DF = CV trap
  1131. ' $E0 ,    ' $E1 ,    ' $00 ,    ' $E3 ,   \ E0, E3 = color
  1132. ' $E4 ,    ' $E5 ,    ' $E6 ,    ' $E7 ,   \ E4, E7 = $C300 trap
  1133. ' $E8 ,    ' $E9 ,    ' $EA ,    ' $EB ,   \ E8, EB = LineTo
  1134. ' $EC ,    ' $ED ,    ' $EE ,    ' $EF ,   \ EC, EF = MoveTo
  1135. ' $F0 ,    ' $F1 ,    ' $F2 ,    ' $F3 ,   \ F0, F3 = cout trap
  1136. ' $00 ,    ' $F5 ,    ' $F6 ,    ' $F7 ,   \ F4, F7 = output cr trap
  1137. ' $F8 ,    ' $F9 ,    ' $FA ,    ' $FB ,   \ F8, FB = getkey trap
  1138. ' $00 ,    ' $FD ,    ' $FE ,    ' $FF ,   \ FC, FF = ProDOS trap
  1139.  
  1140. \ Microprocessor Simulator Words
  1141.  
  1142. : initialize 
  1143.     1FF S !    \ system stack grows downward
  1144.     FF BF00 $! \ set ProDOS trap
  1145.     2000 PC !  \ set program counter to startup address: QForth start
  1146.  
  1147.     1 24 $!  \ start at home position
  1148.     1 25 $!
  1149.  
  1150.     0 $0000 10018 + ! \ zero startup word address
  1151.  
  1152.     \ patches to QForth
  1153.  
  1154.    0BE 23F9 $! \ change prompt from ':' to '>'
  1155.     00 23F4 $! \ no return before each GETLN
  1156.     01 2941 $! \ no cr on startup message
  1157.    0DF 3A8C $! 60 3A8D $! \ patch CV
  1158.    0DB 3A9A $! 60 3A9B $! \ patch CH
  1159.     A2 3C79 $! \ patch to fix file buffer error in original QForth!!
  1160.     9E 3C7A $! \ as above
  1161.     60 2A6C $! \ exit 'read' quickly, skip filling buffer with blanks
  1162.     60 2A89 $! \ skip clearing high data bit
  1163.  
  1164.     \ patches to ProDOS and monitor routines
  1165.     
  1166.    0B2 BF98 $! \ MACHID = Apple //e, 128k, 80-col., no clock
  1167.     60 FC22 $! \ BASCALC, return
  1168.     60 FE89 $! \ IN#0
  1169.     60 FE93 $! \ PR#0
  1170.    0E7 C300 $! 60 C301 $! \ trap 80-col. setup
  1171.    0FB FD0C $! 60 FD0D $! \ trap getkey
  1172.    0F7 FD8B $! 60 FD8C $! \ trap output cr
  1173.    0F3 FDED $! 60 FDEE $! \ trap cout
  1174.    0C7 FDDA $! 60 FDDB $! \ trap hex output
  1175.    0F0 FFFE $! FF FFFF $! \ address of BRK routine
  1176.    0CF FFF0 $! 60 FFF1 $! \ "system monitor"
  1177.     
  1178.     \ special additions to QForth
  1179.     
  1180.    0EF FFA0 $! 60 FFA1 $! \ !pen
  1181.    0EB FFB0 $! 60 FFB1 $! \ -to
  1182.    0E3 FFC0 $! 60 FFC1 $! \ color
  1183.    0D7 FFD0 $! 60 FFD1 $! \ plot
  1184.    0D3 FFE0 $! 60 FFE1 $! \ mouse
  1185.    0CB FF90 $! 60 FF91 $! \ random number in FF8E and FF8F
  1186.    0C3 FF80 $! 60 FF81 $! \ set startup
  1187.     
  1188. ;
  1189.  
  1190. : >P \ get current flag settings
  1191.     #N @v 80 *  #V @v 40 * +  #D @v 8 * +  #I @v 4 * +  #Z @v 2 * + #C @v + ;
  1192.  
  1193. : P> \ restore flag settings
  1194.     dup 80 and 0= if #N unset else #N set then
  1195.     dup 40 and 0= if #V unset else #V set then
  1196.     dup  8 and 0= if #D unset else #D set then
  1197.     dup  4 and 0= if #I unset else #I set then
  1198.     dup  2 and 0= if #Z unset else #Z set then
  1199.